home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 20
/
Cream of the Crop 20 (Terry Blount) (1996).iso
/
program
/
fact127.zip
/
FACT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-05-23
|
32KB
|
1,083 lines
PROGRAM Freeware_Archive_Conversion_Tool;
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
| Program: FACT (Freeware Archive Conversion Tool)
| Version: 1.27 - May 23, 1996
| Author: David Daniel Anderson
| Copyright applies, but feel free to use "fair-use" size portions of code.
-----------------------------------------------------------------------------*)
{$M 20480,0,655360}
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
USES DOS, HeapMan;
TYPE
STR128 = STRING[128];
FList = ^FNode;
FNode = RECORD
ArcFName: STRING[12]; { File names of archives to process. }
DelWhenDone: BOOLEAN; { Does FACT delete archive when done? }
Next: FList;
END;
ArcCommands = RECORD
ReCompress: STR128; { Command line for each ReCompressor. }
DeCompress: STR128; { Command line for each DeCompressor. }
DirsCompressed: BOOLEAN; { Does compressor compress dirs? }
END;
VAR
SavedExitProc: POINTER; { CustomExit proc inserted into normal exit. }
ComSpec: PATHSTR; { Used to execute commands. }
WATCH, { If TRUE, ReadLn executed after info messages. }
DelOriginal, { If TRUE, the original archive is deleted. }
QUIET, { If TRUE, most compressor output is suppressed. }
ONE: BOOLEAN; { If TRUE, convert only the primary archive. }
RecursionLevel: BYTE; { How deep the recursion is, affects ZIP archives. }
NewExt: EXTSTR; { New extension -- for recompressed archives. }
ArcString: STRING; { String of extensions of validated compressors. }
ArcArray: Array[1..244] of ArcCommands; { Commands for archive types. }
FileList: FList; { Singly linked list of archives to process. }
FUNCTION getFileName (fn: STR128): NAMESTR; FORWARD;
PROCEDURE NewLine; FORWARD;
PROCEDURE WriteStr (CONST s: STRING); FORWARD;
FUNCTION WordToHex (i: WORD): EXTSTR; FORWARD;
PROCEDURE CustomExit; FAR; {---- Always exit through here ----}
CONST
NL = #13#10;
VAR
message: STRING [79];
BEGIN
ExitProc := SavedExitProc;
IF (ExitCode > 0) THEN BEGIN
NewLine;
WriteStr ('FACT v1.27 - DOS utility: Freeware Archive Conversion Tool.');
WriteStr ('May 23, 1996. Copyright (c) 1996 by David Daniel Anderson - Reign Ware.'+NL);
WriteStr (' Usage : FACT archives .NewExt [-d] [-q] [-w] [-1]'+NL);
WriteStr (' Where : "archives" is specification of the archives to convert.');
WriteStr (' : ".NewExt" is the extension(s) you wish to convert them to.');
WriteStr (' : "-d"=del - forces the original archive to be deleted. [Optional]');
WriteStr (' : "-q"=quiet - hides most of the compressors'' messages. [Optional]');
WriteStr (' : "-w"=watch - causes FACT to pause after every action. [Optional]');
WriteStr (' : "-1"=1 level - only recompress the _primary_ archive. [Optional]'+NL);
WriteStr ('Examples : FACT c:\dls\*.zip .lzh');
WriteStr (' : FACT somefile.arc .arj .zip .uc2 -d');
WriteStr (' : FACT anyfiles.* .rar -d -q'+NL);
WriteStr (' Hints : DOS wildcards may be used when specifying the archives.');
WriteStr (' : Multiple ".NewExt" new extensions may be specified at one time.'+NL);
END;
IF ErrorAddr <> NIL THEN
BEGIN
WriteStr ('An unanticipated error occurred, please contact DDA with the following data:');
WriteLn ('Address = ', WordToHex (Seg (ErrorAddr^)), ':', WordToHex (Ofs (ErrorAddr^)));
WriteLn ('Code = ', ExitCode);
ErrorAddr := NIL;
END
ELSE
IF (ExitCode IN [1..254]) THEN BEGIN
CASE ExitCode OF
1 : message := 'No '+getFileName (ParamStr (0))+'.INI file found. It must be in same dir as '+ParamStr(0)+'.';
2 : message := 'No defined archives found matching "'+ParamStr(1)+'"!';
3 : message := 'None of the ".NewExt" compressors were validated.';
4 : message := 'User aborted while in "watch" mode. Working files may remain!';
6 : message := '"COMSPEC" not set! Type "COMSPEC=c:\dos\command.com" (or similar) to set it.';
7 : message := 'File handling error. There are likely files and directories to clean up now.';
ELSE message := 'Unknown error.';
END;
WriteLn ('Error encountered (#', ExitCode, '):'); WriteStr (message);
END;
END;
PROCEDURE CheckIO; { Check IOResult, exit on error. }
BEGIN
IF IOResult <> 0 THEN Halt (7);
END;
PROCEDURE NewLine;
BEGIN
WriteLn;
END;
PROCEDURE WriteStr (CONST s: STRING);
BEGIN
WriteLn (s);
END;
FUNCTION WordToHex (i: WORD): EXTSTR; {Convert a WORD variable to STRING[4]}
CONST
HexLetters : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
BEGIN
WordToHex := Concat (HexLetters [Hi (i) SHR 4], HexLetters [Hi (i) AND 15],
HexLetters [Lo (i) SHR 4], HexLetters [Lo (i) AND 15]);
END;
PROCEDURE ClrScr; ASSEMBLER;
(* Routine from SWAG *)
ASM
MOV AH, 0Fh
Int 10h
MOV AH, 0
Int 10h
END;
PROCEDURE Delay (ms : WORD); ASSEMBLER;
ASM {machine independent Delay Function}
mov AX, 1000;
mul ms;
mov CX, DX;
mov DX, AX;
mov AH, $86;
Int $15;
END;
PROCEDURE Pause; { Pauses for WATCH mode. }
FUNCTION ReadKey: CHAR;
VAR
r: REGISTERS;
BEGIN
r. AX := $0700;
Intr ($21, r);
ReadKey := Chr (r. AL);
END;
VAR
k: CHAR;
BEGIN
NewLine;
WriteStr ('Watch mode: press "N" to stop watching, or "A" to abort FACT.');
Write ('Otherwise, press any other normal key to continue ... ');
k := ReadKey;
Write (k);
IF k IN ['n', 'N'] THEN WATCH := FALSE;
IF k IN ['a', 'A'] THEN Halt (4);
NewLine;
NewLine;
END;
FUNCTION CommandProg (fn : STR128): STR128; {Separate prog name from switches.}
BEGIN
IF (Pos (#32, fn) > 0)
THEN CommandProg := Copy (fn, 1, (Pos (#32, fn) - 1))
ELSE CommandProg := fn;
END;
FUNCTION CommandTail (fn : STR128): STR128; {Separate prog switches from name.}
BEGIN
IF (Pos (#32, fn) > 0)
THEN CommandTail := Copy (fn, Pos (#32, fn), Length (fn))
ELSE CommandTail := '';
END;
FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
BEGIN
WHILE (Length (bstr) < len) DO
bstr := bstr + #32;
RPad := bstr;
END;
FUNCTION RTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
Dec (InStr [0]);
RTrim := InStr;
END;
FUNCTION LTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
Delete (InStr, 1, 1);
LTrim := InStr;
END;
FUNCTION Trim (InStr: STRING): STRING;
BEGIN
Trim := RTrim (LTrim (InStr));
END;
FUNCTION Upper (lstr: STRING): STRING;
PROCEDURE UpFast (VAR Str: STRING); {** from SWAG **}
INLINE($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
$AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
BEGIN
UpFast (lstr);
Upper := lstr;
END;
FUNCTION IsSwitch (sSwitch: STRING): BOOLEAN;
VAR
Return : BOOLEAN;
Param : STRING;
pc : BYTE;
BEGIN
Return := FALSE;
IF (ParamCount > 2) THEN
BEGIN
sSwitch := Upper (sSwitch);
FOR pc := 3 to ParamCount DO
IF (Return = FALSE) THEN
BEGIN
Param := Upper (ParamStr (pc));
IF (Pos ('/'+sSwitch, Param) > 0) OR (Pos ('-'+sSwitch, Param) > 0)
THEN Return := TRUE;
END;
END;
IsSwitch := Return;
END;
FUNCTION getFileExt (fn: STR128): EXTSTR;
VAR
p: BYTE;
BEGIN
p := (Pos ('.', fn));
IF (p > 0)
THEN getFileExt := Copy (fn, p, 1 + Length (fn) - p)
ELSE getFileExt := '';
END;
FUNCTION getFileName (fn: STR128): NAMESTR;
VAR
p: BYTE;
b: BOOLEAN;
BEGIN
b := TRUE;
WHILE b DO
BEGIN
p := Pos ('\', fn);
IF (p > 1)
THEN fn := Copy (fn, p+1, Length (fn) - p)